***                                                                                                                                                                                                                                                       
***                                                                                                                                                                                                                                                       
*** This Program already converted to Y2K                                                                                                                                                                                                                 
*** S&T Departement     on 29 April 1999 by Ben.Rahman                                                                                                                                                                                                    
***                                                                                                                                                                                                                                                       
***                                                                                                                                                                                                                                                       
set cent on                                                                                                                                                                                                                                               
*  FILE NAME : PREG1.PRG                                                                                                                                                                                                                                  
*  BY: NURJADI PURNAMA                                                                                                                                                                                                                                    
*  DATE: June 19, 1996                                                                                                                                                                                                                                    
*  DESC:                                                                                                                                                                                                                                                  
*  CALLED BY:                                                                                                                                                                                                                                             
*  DATA FILES:                                                                                                                                                                                                                                            
                                                                                                                                                                                                                                                          
                                                                                                                                                                                                                                                          
** Amended by Dickson - 04/01/99                                                                                                                                                                                                                          
** Split the system date to CCYY, MM & DD                                                                                                                                                                                                                 
  Set Date British                                                                                                                                                                                                                                     
  Today_DD = VAl(SUBSTR(DTOC(DATE()),1,2))                                                                                                                                                                                                                
  Today_MM = VAL(SUBSTR(DTOC(DATE()),4,2))                                                                                                                                                                                                                
  Today_YY = VAL(SUBSTR(DTOC(DATE()),7,4))                                                                                                                                                                                                                
  IF Today_YY < 10                                                                                                                                                                                                                                        
     Today_CCYY = 2000 + Today_YY                                                                                                                                                                                                                         
  ELSE                                                                                                                                                                                                                                                    
     Today_CCYY = 1900 + Today_YY                                                                                                                                                                                                                         
  ENDIF                                                                                                                                                                                                                                                   
**                                                                                                                                                                                                                                                        
**                                                                                                                                                                                                                                                        
SET PROC TO SOSPRO                                                                                                                                                                                                                                        
SET PROC TO BOXPROC                                                                                                                                                                                                                                       
set proc to addrepro                                                                                                                                                                                                                                      
STORE ' ' TO AEANAME,AEAADDR,AEACITY,AEACOUN,AEACURR                                                                                                                                                                                                      
STORE .F. TO AEAHEAL,AEADECI
do start                                                                                                                                                                                                                                                  
DR='N:'                                                                                                                                                                                                                                                   
F1='PATIENT'                                                                                                                                                                                                                                              
F11='NAME'                                                                                                                                                                                                                                                
F12='FNAME'                                                                                                                                                                                                                                               
F13='PATCOD'                                                                                                                                                                                                                                              
F2='COMPANY'                                                                                                                                                                                                                                              
F21='NMCOMP'                                                                                                                                                                                                                                              
F5='EMPREG'                                                                                                                                                                                                                                               
F4='NATIONAL'                                                                                                                                                                                                                                             
F5='PATJAPAN'                                                                                                                                                                                                                                             
F6='PATI'                                                                                                                                                                                                                                                 
F8='CITY'
ANO=.t.
DO WHILE ANO
   ANO=.F.                                                                                                                                                                                                                                                
   STORE 'N' TO SAME,RECOM,CONT                                                                                                                                                                                                                           
   STORE 0 TO P,P1,P2,P3,P4,P5,P6,ANOT,P7,P8,P9,P10,P11,P12,P13,P14,P15,P16,PS1,P21,P22                                                                                                                                                                   
   store CTOD("  /  /    ") to patdob,memval                                                                                                                                                                                                              
   STORE SPACE(1) TO  MINIT,PATSEX,BLOODR,compin,CODTYP,CODCRE,contin,comcod,nmem                                                                                                                                                                         
   AEAM=.F.                                                                                                                                                                                                                                               
   CP=.F.                                                                                                                                                                                                                                                 
   CMEM=SPACE(2)                                                                                                                                                                                                                                          
   BLOODG=SPACE(2)                                                                                                                                                                                                                                        

** 16/06/2000 - Dickson - Start
*  new fields for Marital Indicator and KID indicator
   STORE SPACE(1) to MARITAL, KIDS_IND
   STORE SPACE(40) to U_PAT_REFER
**
** 16/06/2000 - Dickson  - End

   store space(4) to cocod,CODDAT,NATK
   store space(6) to relcod,kodepat                                                                                                                                                                                                                       
   JOBTELEX=SPACE(12)                                                                                                                                                                                                                                     
   pronam=SPACE(15)                                                                                                                                                                                                                                       
   STORE SPACE(16) TO PNAME,PFNAME,PATNAT,mdsnbr,famrelper,PATNATM,PATNATF                                                                                                                                                                                
   fampercod=space(6)                                                                                                                                                                                                                                     
   store space(20) to JOBPERMGR,JOBFINMGR,relper
   store space(8)  to LOCAPTNO
   store space(24) to LOCADD1
   store space(32) to JOBPOSIT,conam                                                                                                                                                                                                              
   STORE SPACE(40) TO HOMADD,LOCADD2,jobadd2,darf,e_mail      
*   Store Space(6) to Arch_cl                                                                                                                                                                                                   
   JOBADD1=SPACE(48)                                                                                                                                                                                                                                      
   store 0 to P,P1                                                                                                                                                                                                                                        
   ada=.f.                                                                                                                                                                                                                                                
   DO WHILE CONT='N'                                                                                                                                                                                                                                      
      SET COLOR TO BG+/B, W+/N                                                                                                                                                                                                                            
      RECOM='N'                                                                                                                                                                                                                                           
      CLEA                                                                                                                                                                                                                                                
      DO ADDRESSS                                                                                                                                                                                                                                         
      DO ADDRPREG                                                                                                                                                                                                                                         
      DO BOXT WITH 7,3,'TO REGISTER A NEW PATIENT TO THE CLINIC','BG+','GR',.F.,.T.                                                                                                                                                                       
      DO BOXE  WITH 10,1,"SURNAME :",'PNAME','BG+','B','W+','N',16,.F.,.F.                                                                                                                                                                                
      DO BOXE  WITH 10,28,'FIRST NAME :','PFNAME','BG+','B','W+','N',16,.F.,.F.                                                                                                                                                                           
      if pname=space(16)                                                                                                                                                                                                                                  
         return                                                                                                                                                                                                                                           
      endif                                                                                                                                                                                                                                               
      LYS=SAVESCREEN(0,0,24,79)                                                                                                                                                                                                                           
*      KEY1=pname+pfname                                                                                                                                                                                                                                   
      KEY2=PFNAME+PNAME                                                                                                                                                                                                                                   
      sele 2                                                                                                                                                                                                                                              
      set exclu off                                                                                                                                                                                                                                       
      use &dr&f2 inde &dr&F2,&dr&f21                                                                                                                                                                                                                      
      SELE 1                                                                                                                                                                                                                                              
      SET EXCLU OFF                                                                                                                                                                                                                                       
      USE &DR&F1 INDE &DR&F11, &DR&F12                                                                                                                                                                                                                    
      sele 1                                                                                                                                                                                                                                              
*      SET INDEX TO &DR&F11                                                                                                                                                                                                                                
*      seek key1                                                                                                                                                                                                                                           
*      if eof()                                                                                                                                                                                                                                            
         SEEK KEY2                                                                                                                                                                                                                                        
         IF EOF()                                                                                                                                                                                                                                         
            SET INDEX TO &DR&F12                                                                                                                                                                                                                          
            *seek key1                                                                                                                                                                                                                                     
            *if eof()                                                                                                                                                                                                                                      
               SEEK KEY2                                                                                                                                                                                                                                  
               IF EOF()                                                                                                                                                                                                                                   
                  OKK=.F.                                                                                                                                                                                                                                 
                  do PREG10                                                                                                                                                                                                                               
               ELSE                                                                                                                                                                                                                                       
                  STORE RECNO() TO REC,RECA                                                                                                                                                                                                               
                  KODEPAT=PAT_FILCOD                                                                                                                                                                                                                      
                  OKK=.T.                                                                                                                                                                                                                                 
               ENDIF                                                                                                                                                                                                                                      
            *else                                                                                                                                                                                                                                          
            *   STORE RECNO() TO REC,RECA                                                                                                                                                                                                                  
            *   KODEPAT=PAT_FILCOD                                                                                                                                                                                                                         
            *   OKK=.T.                                                                                                                                                                                                                                    
            *endif                                                                                                                                                                                                                                         
         ELSE                                                                                                                                                                                                                                             
            STORE RECNO() TO REC,RECA                                                                                                                                                                                                                     
            KODEPAT=PAT_FILCOD                                                                                                                                                                                                                            
            OKK=.T.                                                                                                                                                                                                                                       
         ENDIF                                                                                                                                                                                                                                            
      *else                                                                                                                                                                                                                                                
      *   STORE RECNO() TO REC,RECA                                                                                                                                                                                                                        
      *   KODEPAT=PAT_FILCOD                                                                                                                                                                                                                               
      *   OKK=.T.                                                                                                                                                                                                                                          
      *endif                                                                                                                                                                                                                                               
      IF OKK                                                                                                                                                                                                                                              
         patcod=pat_filcod                                                                                                                                                                                                                                
         patnat=pat_natio                                                                                                                                                                                                                                 
         patdob=pat_dob                                                                                                                                                                                                                                   
         patsex=pat_sex                                                                                                                                                                                                                                   
         SET COLOR TO W/R                                                                                                                                                                                                                                 
         @ 16,1 CLEA TO 20,78                                                                                                                                                                                                                             
         do boxt with 16,1,"A Patient with same Name and First Name is registered under Code : "+patcod,'gr+*','r',.f.,.f.                                                                                                                                
         do boxt with 18,1,'Sex : '+patsex+',   D.O.B. : '+dtoc(patdob)+",  Nationality : "+ltrim(patnat),'gr+*','r',.f.,.f.                                                                                                                              
         do box2 with 21,3,"IS IT THE SAME PATIENT :","YES",'NO','GR+','RB','GR+','R',P,.F.,.T.                                                                                                                                                           
         SAME='N'                                                                                                                                                                                                                                         
         DO CASE                                                                                                                                                                                                                                          
         CASE LASTKEY()=27                                                                                                                                                                                                                                
            RETURN                                                                                                                                                                                                                                        
         CASE P=1                                                                                                                                                                                                                                         
            set color to w+/b                                                                                                                                                                                                                             
            @ 16,1 clea to 23,78                                                                                                                                                                                                                          
            DO BOX2 WITH 21,3,"DO YOU WANT TO REGISTER ANOTHER PATIENT ?",'YES','NO','gr+','r','gR+','B',P1,.f.,.T.                                                                                                                                       
            SET COLOR TO BG+/B,W+/N                                                                                                                                                                                                                       
            IF P1=2 .OR. LASTKEY()=27                                                                                                                                                                                                                     
               RETURN                                                                                                                                                                                                                                     
            ELSE                                                                                                                                                                                                                                          
               CONT='N'                                                                                                                                                                                                                                   
               SET COLO TO BG+/B,W+/N                                                                                                                                                                                                                     
               STORE SPACE(16) TO PNAME,PFNAME,PATNAT,mdsnbr,famrelper,PATNATM,PATNATF                                                                                                                                                                    
               RESTSCREEN(0,0,24,79,LYS)                                                                                                                                                                                                                  
               LOOP                                                                                                                                                                                                                                       
            ENDIF                                                                                                                                                                                                                                         
         endcase                                                                                                                                                                                                                                          
      ENDIF                                                                                                                                                                                                                                               
      SET COLO TO BG+/B,W+/N                                                                                                                                                                                                                              
      RESTSCREEN(0,0,24,79,LYS)                                                                                                                                                                                                                           
      SELE 1                                                                                                                                                                                                                                              
      set exclu off                                                                                                                                                                                                                                       
      USE                                                                                                                                                                                                                                                 
      IF LASTKEY()=27                                                                                                                                                                                                                                     
         RETURN                                                                                                                                                                                                                                           
      ENDIF                                                                                                                                                                                                                                               
      DO WHILE RECOM='N'                                                                                                                                                                                                                                  
         patdob=ctod('  /  /    ')                                                                                                                                                                                                                        
         DO BOXO WITH 10,59,"MID. INITIAL :",'MINIT','BG+','B','W+','N',1,.F.,.F.                                                                                                                                                                         
         IF LASTKEY()=27                                                                                                                                                                                                                                  
            EXIT                                                                                                                                                                                                                                          
         ENDIF                                                                                                                                                                                                                                            
         DO BOXD WITH 12,1,'DATE OF BIRTH:','PATDOB','BG+','B','W+','N','DATE()','DATE()-36500',.F.,.F.                                                                                                                                                  
         ly1=savescreen(0,0,24,79)                                                                                                                                                                                                                        
         DO BOXT WITH 12,28,"NATIONALITY :",'BG+','B',.F.,.F.                                                                                                                                                                                             
         DO WHILE PATNATM=SPACE(16) .AND. PATNATF=SPACE(16)                                                                                                                                                                                               
            DO NATIONAL                                                                                                                                                                                                                                   
            IF LASTKEY()=27                                                                                                                                                                                                                               
               SET COLOR TO BG+/B                                                                                                                                                                                                                         
               @ 12,0 CLEA TO 23,78                                                                                                                                                                                                                       
               LOOP                                                                                                                                                                                                                                       
            ENDif                                                                                                                                                                                                                                         
         ENDDO                                                                                                                                                                                                                                            
         restscreen(0,0,24,79,ly1)                                                                                                                                                                                                                        
         IF LASTKEY()=27                                                                                                                                                                                                                                  
            EXIT                                                                                                                                                                                                                                          
         ENDIF                                                                                                                                                                                                                                            
         SET COLOR TO BG+/B                                                                                                                                                                                                                               
         @ 12,28 CLEA TO 23,78                                                                                                                                                                                                                            
         DO BOXT WITH 12,28,"NATIONALITY : "+ALLTRIM(PATNATM),'BG+','B',.F.,.F.                                                                                                                                                                           
         ps1=1                                                                                                                                                                                                                                            
         DO BOX2 WITH 12,63,"SEX :",'M','F','BG+','B','W+','N',PS1,.F.,.F.                                                                                                                                                                                
         IF LASTKEY()=27                                                                                                                                                                                                                                  
            EXIT                                                                                                                                                                                                                                          
         ENDIF                                                                                                                                                                                                                                            
         IF PS1=1                                                                                                                                                                                                                                         
            PATSEX='M'                                                                                                                                                                                                                                    
            PATNAT=PATNATM                                                                                                                                                                                                                                
         ELSE                                                                                                                                                                                                                                             
            PATSEX='F'                                                                                                                                                                                                                                    
            PATNAT=PATNATF                                                                                                                                                                                                                                
         ENDIF                                                                                                                                                                                                                                            
         @ 12,28 CLEA TO 23,78                                                                                                                                                                                                                            
         DO BOXT WITH 12,28,"NATIONALITY : "+ALLTRIM(PATNAT)+'     SEX : '+PATSEX,'BG+','B',.F.,.F.
**
** Dickson - start (18-June-2001) - Requested by Tanya to remove these fields
** Reactive by Buu (23/11/2001) - Requested by Tanya
         @ 15, 3 say "Blood Group :"                                                                                                                                                                                                                      
         @ 15,21 say "Rhesus  :"
         @ 15,17 SAY BLOODG
         @ 15,31 SAY BLOODR                                                                                                                                                                                                                               
         @ 15,17 GET BLOODG  PICT "@!" VALID(BLOODG $ "'A ''B 'O 'AB''  '")                                                                                                                                                                               
         @ 15,31 GET BLOODR  PICT "@!" VALID(BLOODR $ "'+''-'' '")                                                                                                                                                                                        
         READ
** Dickson - end (18-June-2001)

**
**   16/06/2000 - Dickson - Start
**       add in new fields - MARITAL & KIDS Indicator
   store .f. to DONE
   DO WHILE .NOT. DONE
         @ 17,3  say "Single/Married (S/M):"
         @ 17,30 say "With KIDs (Y/N)? :"

         @ 17,25  SAY MARITAL
         @ 17,49  say KIDS_IND

         @ 17,25  GET MARITAL PICT "@!" VALID(MARITAL $ "'S''M''s''m'")
         @ 17,49  GET KIDS_IND PICT "@!" VALID(KIDS_IND $ "'Y''y''N''n'")
         READ

         if lastkey() <> 27
            DONE = .T.
         endif
   ENDDO
** 16/06/2000 - Dickson - End

         DO BOX2 WITH 21,3,"DO YOU WANT TO ",'CONFIRM','CANCEL','gr+','r','gR+','B',P2,.f.,.T.                                                                                                                                                            
         IF P2=2                                                                                                                                                                                                                                          
            DO BOX2 WITH 21,3,"ARE THE PATIENT NAME AND FIRST NAME CORRECT ? :",'YES','NO','gr+','r','gR+','B',P3,.f.,.T.                                                                                                                                 
            store SPACE(16) to patnat,patnatm,patnatf                                                                                                                                                                                                     
            STORE SPACE(1) TO  MINIT,PATSEX,BLOODR

**  16/06/2000 - Dickson - start
            STORE SPACE(1) to MARITAL, KIDS_IND
**  16/06/2000 - Dickson - end
 
            store CTOD("  /  /    ") to patdob                                                                                                                                                                                                            
            BLOODG=SPACE(2)                                                                                                                                                                                                                               
            IF P3=2                                                                                                                                                                                                                                       
               RECOM='Y'                                                                                                                                                                                                                                  
            ENDIF                                                                                                                                                                                                                                         
         ELSE                                                                                                                                                                                                                                             
            STORE 'Y' TO RECOM,CONT                                                                                                                                                                                                                       
            SELE 1                                                                                                                                                                                                                                        
            SET EXCLU OFF                                                                                                                                                                                                                                 
            USE &DR&F1                                                                                                                                                                                                                                    
            USE &DR&F1 INDEX &DR&F12,&DR&F1,&dr&f13                                                                                                                                                                                                       
            IF FIL_LOCK(0)                                                                                                                                                                                                                                
               APPE BLANK                                                                                                                                                                                                                                 
               UNLOCK                                                                                                                                                                                                                                     
            ENDIF                                                                                                                                                                                                                                         
            rec=RECNO()                                                                                                                                                                                                                                   
            recpat=recno()                                                                                                                                                                                                                                
            do boxt with 7,49,"RECORD : "+STR(rec,6),'gr+','r',.f.,.T.                                                                                                                                                                                    
         ENDIF                                                                                                                                                                                                                                            
         SET COLOR TO W+/B                                                                                                                                                                                                                                
         @ 21,1 CLEA TO 23,78                                                                                                                                                                                                                             
      ENDDO                                                                                                                                                                                                                                               
      IF LASTKEY()=27                                                                                                                                                                                                                                     
         EXIT                                                                                                                                                                                                                                             
      ENDIF                                                                                                                                                                                                                                               
   ENDDO                                                                                                                                                                                                                                                  
   IF LASTKEY()=27                                                                                                                                                                                                                                        
      ANO=.T.                                                                                                                                                                                                                                             
      LOOP                                                                                                                                                                                                                                                
   ENDIF                                                                                                                                                                                                                                                  
                                                                                                                                                                                                                                                          
   set color to w+/b                                                                                                                                                                                                                                      
   @  7, 1 clea to 23,78                                                                                                                                                                                                                                  
   CONT='N'                                                                                                                                                                                                                                               
   do boxt with 7,3,"ADDRESS of "+alltrim(pfname)+' '+alltrim(pname),'bg+','gr',.f.,.T.                                                                                                                                                                   
   do boxt with 7,58,"RECORD : "+STR(rec,6),'gr+','r',.f.,.T.                                                                                                                                                                                             
   set color to w+/b                                                                                                                                                                                                                                      
   DO WHILE CONT='N'                                                                                                                                                                                                                                      
      store space(14) to HOMCITY,homtel,loctel,HOMCOUNT
      store space(16) to loccity
      IF LASTKEY()=27
         go recpat                                                                                                                                                                                                                                        
         if rec_lock()                                                                                                                                                                                                                                    
            dele                                                                                                                                                                                                                                          
         endif                                                                                                                                                                                                                                            
         unlock                                                                                                                                                                                                                                           
         RETURN                                                                                                                                                                                                                                           
      ENDIF                                                                                                                                                                                                                                               
**
**  12/05/2000 - start - Dickson - to reduce the unneccessary entries by Recep,
**               remove the Home Address fields
**       
**      do boxe with 10,1,"Address :",'homadd','BG+','B','W+','N',40,.F.,.F.
**      do boxe with 10,54,"City :",'homCITY','BG+','B','W+','N',14,.F.,.F.                                                                                                                                                                                 
**      do boxt with 12,1,"Country :",'BG+','B',.F.,.F.                                                                                                                                                                                                     
**      do nationad                                                                                                                                                                                                                                         
**      set color to bg+/b                                                                                                                                                                                                                                  
**      @  12,1 clea to 23,78                                                                                                                                                                                                                               
**      do boxt with 12,1,"Country : "+homcount,'BG+','B',.F.,.F.                                                                                                                                                                                           
**      do boxe with 12,32,"Tel. :",'homTEL','BG+','B','W+','N',14,.F.,.F.                                                                                                                                                                                  
**      IF left(HOMCOUNT,5)<>SUBS(AEACOUN,1,5)                                                                                                                                                                                                              
         DO BOXT     WITH  10,1,"Address in "+alltrim(AEACOUN),'BG+','B',.F.,.F.

         DO BOXE WITH 12,1,"No/Apartment No   :",'LOCAPTNO','BG+','B','W+','N',8,.F.,.F.
** Buu - Archives for clinic 31/07/2003
**         DO BOXEN WITH 12,40,"Archives Clinic :",'ARCH_CL','BG+','B','W+','N',8,.F.,.F.
** Buu - End Archives for clinic 31/07/2003
         DO BOXNOE WITH 14,1,"Address (line 1)  :",'LOCADD1','BG+','B','W+','N',24,.F.,.F.
         DO BOXEN WITH 16,1,"Address (line 2)  :",'LOCADD2','BG+','B','W+','N',40,.F.,.F.                                                                                                                                                                  
*        DO BOXNOE WITH 18,1,"City :",'LOCcity','BG+','B','W+','N',14,.F.,.F.                                                                                                                                                                               
*---
         ly1=savescreen(0,0,24,79)                                                                                                                                                                                                                        
         DO BOXT WITH 18,1,"CITY :",'BG+','B',.F.,.F.
         STORE space(16) to uCity 
         DO WHILE uCity=SPACE(16)
            DO CITY
            IF LASTKEY()=27                                                                                                                                                                                                                               
               SET COLOR TO BG+/B                                                                                                                                                                                                                         
               @ 12,0 CLEA TO 23,78                                                                                                                                                                                                                       
               LOOP                                                                                                                                                                                                                                       
            ENDIF

         ENDDO                                                                                                                                                                                                                                            
         restscreen(0,0,24,79,ly1)                                                                                                                                                                                                                        
         IF LASTKEY()=27                                                                                                                                                                                                                                  
            EXIT                                                                                                                                                                                                                                          
         ENDIF                                                                                                                                                                                                                                            
         SET COLOR TO BG+/B                                                                                                                                                                                                                               
         @ 18,2 CLEA TO 20,78 
         LOCCity = uCity
         DO BOXT WITH 18,1,"CITY : "+ALLTRIM(LOCCity),'BG+','B',.F.,.F.
         DO BOXE WITH 18,32,"Tel.1:",'LOCtel','BG+','B','W+','N',14,.F.,.F.
         DO BOXEN WITH 20,32,"Tel.2:",'HOMtel','BG+','B','W+','N',14,.F.,.F. 
** Buu - Email address 24/6/03
	   DO BOXEN WITH 22,1,"Email:",'E_mail','BG+','B','W+','N',40,.F.,.F. 
** Buu - Email End
**      ENDIF                                                                                                                                                                                                                                               
**  12/05/2000 - end

      DO BOX2 WITH 21,3,"DO YOU WANT TO ",'CONFIRM','CANCEL','gr+','r','gR+','B',P4,.f.,.T.
      IF P4=1                                                                                                                                                                                                                                             
         cont='Y'                                                                                                                                                                                                                                         
      ENDIF                                                                                                                                                                                                                                               
      IF LASTKEY()=27                                                                                                                                                                                                                                     
         SELE 1                                                                                                                                                                                                                                           
         go recpat                                                                                                                                                                                                                                        
         if rec_lock()                                                                                                                                                                                                                                    
            dele                                                                                                                                                                                                                                          
         endif                                                                                                                                                                                                                                            
         unlock                                                                                                                                                                                                                                           
                                                                                                                                                                                                                                                          
         RETURN                                                                                                                                                                                                                                           
      ENDIF                                                                                                                                                                                                                                               
                                                                                                                                                                                                                                                          
   ENDDO                                                                                                                                                                                                                                                  
   set color to w+/b                                                                                                                                                                                                                                      
   @  7, 1 clea to 23,78                                                                                                                                                                                                                                  
   CONT='N'                                                                                                                                                                                                                                               
   do boxt with 7,3,"EMPLOYMENT of "+alltrim(pfname)+' '+alltrim(pname),'bg+','gr',.f.,.T.                                                                                                                                                                
   do boxt with 7,58,"RECORD : "+STR(rec,6),'gr+','r',.f.,.T.                                                                                                                                                                                             
                                                                                                                                                                                                                                                          
   DO WHILE CONT='N'                                                                                                                                                                                                                                      
      STORE SPACE(16) TO JOBCITY,JOBCOUNT,JOBTEL1,JOBTEL2,JOBTEL3                                                                                                                                                                                         
      JOBFAX=SPACE(14)                                                                                                                                                                                                                                    
      IF LASTKEY()=27                                                                                                                                                                                                                                     
         SELE 1                                                                                                                                                                                                                                           
         go recpat                                                                                                                                                                                                                                        
         if rec_lock()                                                                                                                                                                                                                                    
            dele                                                                                                                                                                                                                                          
         endif                                                                                                                                                                                                                                            
         unlock                                                                                                                                                                                                                                           
                                                                                                                                                                                                                                                          
         RETURN                                                                                                                                                                                                                                           
      ENDIF                                                                                                                                                                                                                                               
      set color to w+/b                                                                                                                                                                                                                                   
      @ 10,1 clea to 12,78                                                                                                                                                                                                                                
      do box2 with 12,3,"Do you have a company's name ? :",'YES','NO','gr+','r','gR+','b',P6,.f.,.t.                                                                                                                                                      
      SET COLOR TO W+/B                                                                                                                                                                                                                                   
      @ 12,1 CLEA TO 14,78                                                                                                                                                                                                                                
      IF P6=2 .or. lastkey()=27                                                                                                                                                                                                                           
         cocod='0000'                                                                                                                                                                                                                                     
      else                                                                                                                                                                                                                                                
         *         do boxi with 12,1,"Initial of Company's Name :",'compin','BG+','b','w+','n',.f.,.f.                                                                                                                                                    
         compin=space(5)                                                                                                                                                                                                                                  
         do boxe with 10,3,'Enter Initial of company name : ','COMPIN','N','BG','W+','N',5,.T.,.T.                                                                                                                                                        
         if lastkey()=27                                                                                                                                                                                                                                  
            cocod='0000'                                                                                                                                                                                                                                  
         else                                                                                                                                                                                                                                             
            do PREG401                                                                                                                                                                                                                                    
         endif                                                                                                                                                                                                                                            
         set color to w+/b                                                                                                                                                                                                                                
         @ 10,1 clea to 23,78            
* Buu - Not allow for add-in new company in this screen                                                                                                                                                                                                                 
         if cocod='0000'                                                                                                                                                                                                                                  
            do boxt with 10,1,'This Company does not exist - Pls enter it','bg+','b',.f.,.f.                                                                                                                                                                                    
  *          do boxe with 10,1,"Company :",'conam','BG+','B','W+','N',32,.F.,.F.                                                                                                                                                                           
   *         do boxe with 12,1,"Address :",'jobadd1','BG+','B','W+','N',48,.F.,.F.                                                                                                                                                                         
    *        do boxe with 14,1,"Nber & Street :",'jobadd2','BG+','B','W+','N',32,.F.,.F.                                                                                                                                                                   
     *       do boxe with 14,51,"City :",'jobcity','BG+','B','W+','N',16,.F.,.F.                                                                                                                                                                           
      *      do boxe with 16,1,"Country :",'jobcount','BG+','B','W+','N',16,.F.,.F.                                                                                                                                                                        
       *     do boxe with 16,32,"Fax :",'jobfax','BG+','B','W+','N',14,.F.,.F.                                                                                                                                                                             
        *    do boxe with 18,1,"Telephone :",'jobtel1','BG+','B','W+','N',16,.F.,.F.                                                                                                                                                                       
         *   do boxe with 18,32,"or :",'jobtel2','BG+','B','W+','N',16,.F.,.F.                                                                                                                                                                             
          *  do boxe with 18,54,"or :",'jobtel3','BG+','B','W+','N',16,.F.,.F.                                                                                                                                                                             
         else                          
            SELE 2                                                                                                                                                                                                                                        
            SET EXCLU OFF                                                                                                                                                                                                                                 
            use &dr&f2 INDE &DR&F2                                                                                                                                                                                                                        
            SEEK COCOD                                                                                                                                                                                                                                    
            IF .NOT. EOF()                                                                                                                                                                                                                                
               CONAM=COMP_NAME                                                                                                                                                                                                                            
               JOBADD1=COMP_ADD1                                                                                                                                                                                                                          
               JOBADD2=COMP_ADD2                                                                                                                                                                                                                          
               JOBCITY=COMP_CITY                                                                                                                                                                                                                          
               JOBCOUNT=COMP_COUNT                                                                                                                                                                                                                        
               JOBTEL1=COMP_TEL1                                                                                                                                                                                                                          
               JOBTEL2=COMP_TEL2                                                                                                                                                                                                                          
               JOBTEL3=COMP_TEL3                                                                                                                                                                                                                          
               JOBFAX=COMP_FAX                                                                                                                                                                                                                            
               AEAM  = AEA_MEMBER                                                                                                                                                                                                                         
               CMEM  = MEMB_CODE                                                                                                                                                                                                                          
               F7='PROGRAM'                                                                                                                                                                                                                               
               SELE 6                                                                                                                                                                                                                                     
               SET EXCLU OFF                                                                                                                                                                                                                              
               USE &DR&F7                                                                                                                                                                                                                                 
               LOCATE FOR PROGRAM_CD=CMEM                                                                                                                                                                                                                 
               IF FOUND()                                                                                                                                                                                                                                 
**  Amended by dickson - wrong field name in the 'PROGRAM.DBF' file                                                                                                                                                                                       
**                  NMEM=MEMB_NAME                                                                                                                                                                                                                        
                  NMEM=PROGRAM_NM                                                                                                                                                                                                                         
**                                                                                                                                                                                                                                                        
**  end amend by dickson                                                                                                                                                                                                                                  
               ENDIF                                                                                                                                                                                                                                      
               SELE 2                                                                                                                                                                                                                                     
               do boxt with 10,51,"Company Code : "+COCOD,'bg+','b',.f.,.f.                                                                                                                                                                               
               do boxT with 10,1,"Company : "+ALLTRIM(conam),'BG+','B',.F.,.F.                                                                                                                                                                            
               do boxT with 12,1,"Address : "+ALLTRIM(jobadd1),'BG+','B',.F.,.F.                                                                                                                                                                          
               do boxT with 14,1,"Nber & Street : "+ALLTRIM(JOBADD2),'BG+','B',.F.,.F.                                                                                                                                                                    
               do boxT with 14,51,"City : "+ALLTRIM(jobcity),'BG+','B',.F.,.F.                                                                                                                                                                            
               do boxT with 16,1,"Country : "+ALLTRIM(jobcount),'BG+','B',.F.,.F.                                                                                                                                                                         
               do boxT with 16,32,"Fax : "+ALLTRIM(jobfax),'BG+','B',.F.,.F.                                                                                                                                                                              
               do boxT with 18,1,"Telephone : "+ALLTRIM(jobtel1),'BG+','B',.F.,.F.                                                                                                                                                                        
               do boxT with 18,32,"or : "+ALLTRIM(jobtel2),'BG+','B',.F.,.F.                                                                                                                                                                              
               do boxT with 18,54,"or : "+alltrim(jobtel3),'BG+','B',.F.,.F.                                                                                                                                                                              
               IF AEAM                                                                                                                                                                                                                                    
                  do boxT with 21,45,ALLTRIM(NMEM),'GR+','RB',.F.,.T.                                                                                                                                                                                     
               ELSE                                                                                                                                                                                                                                       
                  SET COLO TO BG+/B,W+/N                                                                                                                                                                                                                  
                  @ 21,45 CLEAR TO 23,78                                                                                                                                                                                                                  
               ENDIF                                                                                                                                                                                                                                      
            ENDIF                                                                                                                                                                                                                                         
         ENDIF                                                                                                                                                                                                                                            
      ENDIF                                                                                                                                                                                                                                               
      DO BOX2 WITH 21,3,"DO YOU WANT TO ",'CONFIRM','CANCEL','gr+','r','gR+','B',P7,.f.,.T.                                                                                                                                                               
      IF P7=1                                                                                                                                                                                                                                             
         cont='Y'                                                                                                                                                                                                                                         
      else                                                                                                                                                                                                                                                
         compin=space(1)                                                                                                                                                                                                                                  
      ENDIF                                                                                                                                                                                                                                               
      IF LASTKEY()=27                                                                                                                                                                                                                                     
         SELE 1                                                                                                                                                                                                                                           
         go recpat                                                                                                                                                                                                                                        
         if rec_lock()                                                                                                                                                                                                                                    
            dele                                                                                                                                                                                                                                          
         endif                                                                                                                                                                                                                                            
         unlock                                                                                                                                                                                                                                           
         RETURN                                                                                                                                                                                                                                           
      ENDIF                                                                                                                                                                                                                                               
   ENDDO                                                                                                                                                                                                                                                  

**
** --------------------- Cash Less Medical Services -----------------
   set color to w+/b
   @  7, 1 clea to 23,78                                                                                                                                                                                                                                  
   CONT='N'                                                                                                                                                                                                                                               
   do boxt with 7,3,"MEMBERSHIP STATUS of "+alltrim(pfname)+' '+alltrim(pname),'bg+','gr',.f.,.T.                                                                                                                                                         
   do boxt with 7,58,"RECORD : "+STR(rec,6),'gr+','r',.f.,.T.                                                                                                                                                                                             
   set color to w+/b                                                                                                                                                                                                                                      
   LAY=SAVESCREEN(0,0,24,79)                                                                                                                                                                                                                              
   DO WHILE CONT='N'                                                                                                                                                                                                                                      
      store CTOD("  /  /    ") to AEADAT,mdsdat                                                                                                                                                                                                           
      store .f. to PER,DOC,FAM,MDS,relper,reldoc                                                                                                                                                                                                          
      SET COLOR TO BG+/B                                                                                                                                                                                                                                  
      @ 13,1 CLEA TO 23,78                                                                                                                                                                                                                                
      IF PATNAT <>'ALIEN'                                                                                                                                                                                                                                 
         P10=1                                                                                                                                                                                                                                            
** Dickson - Start (18-June-2001) - Set the default of CMS to NO so that the systems don't ask for CMS info. anymore
         P10=2
**         DO BOX2 WITH 16,3,"Cashless Medical Services :",'YES','NO','gr+','r','gR+','B',P10,.f.,.T.
** Dickson - End (18-June-2001)

         SET COLOR TO BG+/B
         @ 16,1 CLEA TO 23,78                                                                                                                                                                                                                             
         if P10=1                                                                                                                                                                                                                                         
            do boxt with 13,3,"  CASHLESS MEDICAL SERVICES  ",'bg+*','gr',.f.,.T.                                                                                                                                                                         
            instyp=space(15)                                                                                                                                                                                                                              
            insnam=space(35)                                                                                                                                                                                                                              
**            insval=ctod("  /  /    ")                                                                                                                                                                                                                     
            VADD=0                                                                                                                                                                                                                                        
            SET COLO TO BG+/B,W+/N                                                                                                                                                                                                                        
            DO JAPINS                                                                                                                                                                                                                                     
            IF VADD=2                                                                                                                                                                                                                                     
               CONT='N'                                                                                                                                                                                                                                   
               LOOP                                                                                                                                                                                                                                       
            ENDIF                                                                                                                                                                                                                                         
                                                                                                                                                                                                                                                          
            do boxT with 16,3,"Insurance Name : "+alltrim(insnam),'gr+','r',.F.,.t.                                                                                                                                                                       
            set colo to bg+/b,w+/n                                                                                                                                                                                                                        
            do while insval=ctod("  /  /    ")                                                                                                                                                                                                            
               @ 20,23 say 'Insurance Validity Date : ' get insval pict '99/99/9999'                                                                                                                                                                      
               @ 20,23 say '               (DD/MM/YY)'                                                                                                                                                                                                    
               read                                                                                                                                                                                                                                       
               lyr=savescreen(0,0,24,79)                                                                                                                                                                                                                  
                                                                                                                                                                                                                                                          
** Amended by Dickson - to handle the Expiry date beyond year 2000                                                                                                                                                                                        
**                                                                                                                                                                                                                                                        
            INSVAL_DD = VAL(SUBSTR(dtoc(INSVAL),1,2))                                                                                                                                                                                                     
            INSVAL_MM = VAL(SUBSTR(dtoc(INSVAL),4,2))                                                                                                                                                                                                     
            INSVAL_YY = VAL(SUBSTR(dtoc(INSVAL),7,4))                                                                                                                                                                                                     
            IF INSVAL_YY < 10                                                                                                                                                                                                                             
               INSVAL_CCYY = 2000 + INSVAL_YY                                                                                                                                                                                                             
            ELSE                                                                                                                                                                                                                                          
               INSVAL_CCYY = 1900 + INSVAL_YY                                                                                                                                                                                                             
            ENDIF                                                                                                                                                                                                                                         
                                                                                                                                                                                                                                                          
            CARD_EXPIRED = .T.                                                                                                                                                                                                                            
            IF INSVAL_CCYY < TODAY_CCYY                                                                                                                                                                                                                   
               CARD_EXPIRED = .T.                                                                                                                                                                                                                         
            ELSEIF INSVAL_CCYY > TODAY_CCYY                                                                                                                                                                                                               
               CARD_EXPIRED = .F.                                                                                                                                                                                                                         
                                                                                                                                                                                                                                                          
                      ** same year                                                                                                                                                                                                                        
            ELSE                                                                                                                                                                                                                                          
                                                                                                                                                                                                                                                          
               IF INSVAL_MM < TODAY_MM                                                                                                                                                                                                                    
                  CARD_EXPIRED = .T.                                                                                                                                                                                                                      
               ELSEIF  INSVAL_MM > TODAY_MM                                                                                                                                                                                                               
                  CARD_EXPIRED = .F.                                                                                                                                                                                                                      
                                                                                                                                                                                                                                                          
                      ** same month                                                                                                                                                                                                                       
               ELSE                                                                                                                                                                                                                                       
                  IF  INSVAL_DD < TODAY_DD                                                                                                                                                                                                                
                      CARD_EXPIRED = .T.                                                                                                                                                                                                                  
                  ELSE                                                                                                                                                                                                                                    
                      CARD_EXPIRED = .F.                                                                                                                                                                                                                  
                  ENDIF                                                                                                                                                                                                                                   
               ENDIF                                                                                                                                                                                                                                      
            ENDIF                                                                                                                                                                                                                                         
                                                                                                                                                                                                                                                          
            IF  CARD_EXPIRED = .T.                                                                                                                                                                                                                        
**               IF INSVAL<DATE()                                                                                                                                                                                                                         
**                                                                                                                                                                                                                                                        
**  End Amendment by Dickson                                                                                                                                                                                                                              
**                                                                                                                                                                                                                                                        
                  do boxT with 21,25,"Insurance Card Has Already Expired",'gr+','r',.F.,.t.                                                                                                                                                               
                  set cursor off                                                                                                                                                                                                                          
                  wait''                                                                                                                                                                                                                                  
                  @ 21,25 SAY repl(' ',50)                                                                                                                                                                                                                
                  set cursor on                                                                                                                                                                                                                           
                  insval=ctod("  /  /    ")                                                                                                                                                                                                               
                  set colo to bg+/b,w+/n                                                                                                                                                                                                                  
                  restscreen(0,0,24,79,lyr)                                                                                                                                                                                                               
                  loop                                                                                                                                                                                                                                    
               endif                                                                                                                                                                                                                                      
            enddo                                                                                                                                                                                                                                         
         endif                                                                                                                                                                                                                                            
         IF LASTKEY()=27                                                                                                                                                                                                                                  
            SELE 1                                                                                                                                                                                                                                        
            go recpat                                                                                                                                                                                                                                     
            if rec_lock()                                                                                                                                                                                                                                 
               dele                                                                                                                                                                                                                                       
            endif                                                                                                                                                                                                                                         
            unlock                                                                                                                                                                                                                                        
            RETURN                                                                                                                                                                                                                                        
         ENDIF                                                                                                                                                                                                                                            
      ENDIF                                                                                                                                                                                                                                               

**
** --------- prompt for Member Type -----------------------
      IF PATNAT <>'ALIEN'

         @ 13,1 CLEA TO 23,78
               SELE 6                                                                                                                                                                                                                                     
*               F7='MSHTYPE'                                                                                                                                                                                                                              
               F7='PROGRAM'                                                                                                                                                                                                                               
                                                                                                                                                                                                                                                          
               SELE 6                                                                                                                                                                                                                                     
               SET EXCLU OFF                                                                                                                                                                                                                              
               USE &DR&F7                                                                                                                                                                                                                                 
               COUNT TO CNT                                                                                                                                                                                                                               
               IF CNT=0                                                                                                                                                                                                                                   
                  RESTSCREEN(0,0,24,79,LAY)                                                                                                                                                                                                               
                  LOOP                                                                                                                                                                                                                                    
               ENDIF                                                                                                                                                                                                                                      
               DECLARE FILD[CNT]                                                                                                                                                                                                                          
               DECLARE MCOD[CNT]                                                                                                                                                                                                                          
               DECLARE DARI[CNT]                                                                                                                                                                                                                          
               DECLARE HING[CNT]                                                                                                                                                                                                                          
               DECLARE MNAM[CNT]                                                                                                                                                                                                                          
               SELE 6                                                                                                                                                                                                                                     
               GO TOP                                                                                                                                                                                                                                     
               CR=0                                                                                                                                                                                                                                       
               DO WHILE .NOT. EOF()                                                                                                                                                                                                                       
                   CR=CR+1                                                                                                                                                                                                                                 
*                  FILD[CR]=MEMB_CODE+' '+MEMB_NAME                                                                                                                                                                                                       
*                  MNAM[CR]=MEMB_NAME                                                                                                                                                                                                                     
*                  MCOD[CR]=MEMB_CODE                                                                                                                                                                                                                     
*                  DARI[CR]=MEMB_START                                                                                                                                                                                                                    
*                  HING[CR]=MEMB_END
** Dickson - Start (18-June-2001) change the display/sort sequence to PGM Name instead of PGM Code
**                   FILD[CR]=PROGRAM_CD+' '+PROGRAM_NM                                                                                                                                                                                                     
                   FILD[CR]=PROGRAM_NM+' '+PROGRAM_CD
** Dickson - End (18-June-2001) 
                   MNAM[CR]=PROGRAM_NM
                   MCOD[CR]=PROGRAM_CD                                                                                                                                                                                                                    
                  DARI[CR]=MEMB_START                                                                                                                                                                                                                     
                  HING[CR]=MEMB_END                                                                                                                                                                                                                       
                                                                                                                                                                                                                                                          
                  SKIP                                                                                                                                                                                                                                    
               ENDDO                                                                                                                                                                                                                                      

               set colo to w/b
               inkey()

               do boxT with 14,3,"AEA MEMBER TYPE ",'GR+','RB',.F.,.T.

               AEAM = .F.  
               DO WHILE AEAM <> .T.  
                  set colo to w+/rb,gr+/r
                  @ 16,43 clea to 23,75                                                                                                                                                                                                                      
                  @ 16,43 to 23,75 double                                                                                                                                                                                                                    
                  pilih=achoice(17,45,22,73,FILD)

                  if lastkey()=13
                    AEAM=.T.                                                                                                                                                                                                                                
                    healthline=.t.                                                                                                                                                                                                                          
                    restscreen(0,0,24,79,lay)                                                                                                                                                                                                               
                    DARF=FILD[PILIH]                                                                                                                                                                                                                        
                    CMEM=MCOD[PILIH]                                                                                                                                                                                                                        
                    NMEM=MNAM[PILIH]                                                                                                                                                                                                                        
                    MDR=DARI[PILIH]
                    MHG=HING[PILIH]                                                                                                                                                                                                                         

                    do boxT with 16,4,ALLTRIM(NMEM),'GR+','RB',.F.,.T.

                   ENDIF 
               ENDDO

** ------------ new field added for Dr. Soraya - Network Statistic ----
** Dickson - Start (18-June-2001) - amend for Tanya, if INSURANCE then prompt for INSURANCE NAME
**                IF ALLTRIM(NMEM) = "TOURIST" .OR. ALLTRIM(NMEM) = "TEMP RESIDENT"
** Buu - 19/7/04 : Add in the refer field for Immigration CUP
                IF ALLTRIM(NMEM) = "TOURIST" .OR. ALLTRIM(NMEM) = "TOURIST-OTAI" .OR. ALLTRIM(NMEM) = "TEMP RESIDENT" .OR. ALLTRIM(NMEM) = "TEMP RESID-OTAI" .OR. ALLTRIM(NMEM) = "IMMIGRATION CUP" .OR. ALLTRIM(NMEM) = "OTHER INSURANCE" 
                   set colo to w/b
                   @ 16,43 clea to 23,75
                   IF ALLTRIM(NMEM) = "OTHER INSURANCE"
                      STORE SPACE(35) TO INSNAM
                      DO JAPINS
                      u_PAT_REFER = alltrim(INSNAM)
**                      DO BOXNOE WITH 20,2,"Insurance company :",'U_PAT_REFER','BG+','B','W+','N',30,.F.,.F.
                   ELSE
                      DO BOXNOE WITH 20,2,"Refer by/know from:",'U_PAT_REFER','BG+','B','W+','N',30,.F.,.F.
                   ENDIF     
                ENDIF
** Dickson - End (18-June-2001)
** --------------
      ENDIF                                                                                                                                                                                                                                                     
      IF LASTKEY()=27                                                                                                                                                                                                                                     
         SELE 1                                                                                                                                                                                                                                           
         go recpat                                                                                                                                                                                                                                        
         if rec_lock()                                                                                                                                                                                                                                    
            dele                                                                                                                                                                                                                                          
         endif                                                                                                                                                                                                                                            
         unlock                                                                                                                                                                                                                                           
                                                                                                                                                                                                                                                          
         RETURN                                                                                                                                                                                                                                           
      ENDIF

** --------------------- end of Member Type prompt -----------------------

      do case
      case mds                                                                                                                                                                                                                                            
         CODDAT=SUBSTR(DTOC(MDSDAT),1,2)+SUBSTR(DTOC(MDSDAT),4,2)                                                                                                                                                                                         
** 12/05/2000 - Start - Dickson - Since there is no Membership date hence set to 0000
**      case AEAM .and. .not. mds
**         CODDAT=SUBSTR(DTOC(memval),1,2)+SUBSTR(DTOC(memval),4,2)                                                                                                                                                                                         
** 12/05/2000 - end
      other
         CODDAT="0000"                                                                                                                                                                                                                                    
      ENDCASE                                                                                                                                                                                                                                             
                                                                                                                                                                                                                                                          
      DO CASE                                                                                                                                                                                                                                             
**                                                                                                                                                                                                                                                        
**   8/2/99 - amended by dickson - for the Executive -Care system                                                                                                                                                                                         
**          - Set the Patient Code type to '3' if AEA E-Care membership                                                                                                                                                                                   
                                                                                                                                                                                                                                                          
      CASE AEAM .and. CMEM = "03"                                                                                                                                                                                                                         
         CODTYP='3'                                                                                                                                                                                                                                       
      CASE MDS                                                                                                                                                                                                                                            
         CODTYP='7'                                                                                                                                                                                                                                       
      CASE PER .OR. DOC .OR. FAM                                                                                                                                                                                                                          
         CODTYP='9'                                                                                                                                                                                                                                       
      CASE  AEAM .and. .not. DOC .AND. .NOT. PER .AND. .NOT. FAM                                                                                                                                                                                          
         CODTYP='5'                                                                                                                                                                                                                                       
      OTHER                                                                                                                                                                                                                                               
         CODTYP='6'                                                                                                                                                                                                                                       
      ENDCASE                                                                                                                                                                                                                                             
                                                                                                                                                                                                                                                          
                                                                                                                                                                                                                                                          
      DO BOX2 WITH 21,3,"DO YOU WANT TO ",'CONFIRM','CANCEL','gr+','r','gR+','B',P13,.f.,.T.                                                                                                                                                              
      IF P13=1                                                                                                                                                                                                                                            
         cont='Y'                                                                                                                                                                                                                                         
         IF CMEM='CP'                                                                                                                                                                                                                                     
            CP=.T.                                                                                                                                                                                                                                        
         ENDIF                                                                                                                                                                                                                                            
      ELSE                                                                                                                                                                                                                                                
         AEAM=.F.                                                                                                                                                                                                                                         
      ENDif                                                                                                                                                                                                                                               
      IF LASTKEY()=27                                                                                                                                                                                                                                     
         SELE 1                                                                                                                                                                                                                                           
         go recpat                                                                                                                                                                                                                                        
         if rec_lock()                                                                                                                                                                                                                                    
            dele                                                                                                                                                                                                                                          
         endif                                                                                                                                                                                                                                            
         unlock                                                                                                                                                                                                                                           
         RETURN                                                                                                                                                                                                                                           
      ENDIF                                                                                                                                                                                                                                               
   ENDDO                                                                                                                                                                                                                                                  
   set color to w+/b                                                                                                                                                                                                                                      
   @  7, 1 clea to 23,78                                                                                                                                                                                                                                  
   CONT='N'                                                                                                                                                                                                                                               
   do boxt with 7,3,"FILE PATIENT of "+alltrim(pfname)+' '+alltrim(pname),'bg+','gr',.f.,.T.                                                                                                                                                              
   do boxt with 7,58,"RECORD : "+STR(rec,6),'gr+','r',.f.,.T.                                                                                                                                                                                             
   set color to w+/b                                                                                                                                                                                                                                      
   DO WHILE CONT='N' .and. lastkey()<>27                                                                                                                                                                                                                  
      store date() to datfil,entdat                                                                                                                                                                                                                       
      IF LASTKEY()=27                                                                                                                                                                                                                                     
         SELE 1                                                                                                                                                                                                                                           
         go recpat                                                                                                                                                                                                                                        
         if rec_lock()                                                                                                                                                                                                                                    
            dele                                                                                                                                                                                                                                          
         endif                                                                                                                                                                                                                                            
         unlock                                                                                                                                                                                                                                           
         RETURN                                                                                                                                                                                                                                           
      ENDIF                                                                                                                                                                                                                                               
      AWNAME=left(PNAME,1)                                                                                                                                                                                                                                
      KODEPAT=SPACE(6)                                                                                                                                                                                                                                    
      PATI='PT'+AWNAME                                                                                                                                                                                                                                    
      *      REST FROM N:PATI ADDITIVE                                                                                                                                                                                                                    
      USE &DR&F6                                                                                                                                                                                                                                          
      LOCA FOR PAT_INIT = AWNAME                                                                                                                                                                                                                          
      PNUM=PAT_NUMB+1                                                                                                                                                                                                                                     
      NOWO=ltrim(STR(int(PNUM)))                                                                                                                                                                                                                          
      *      AWNM=left(&PATI,1)                                                                                                                                                                                                                           
      *      NOWO=LTRIM(STR(INT(VAL(SUBSTR(&PATI,2,5))+1)))                                                                                                                                                                                               
      blank=5-len(nowo)                                                                                                                                                                                                                                   
      do case                                                                                                                                                                                                                                             
      case blank=4                                                                                                                                                                                                                                        
         kodepat=awname+'0000'+nowo                                                                                                                                                                                                                       
      case blank=3                                                                                                                                                                                                                                        
         kodepat=awname+'000'+nowo                                                                                                                                                                                                                        
      case blank=2                                                                                                                                                                                                                                        
         kodepat=awname+'00'+nowo                                                                                                                                                                                                                         
      case blank=1                                                                                                                                                                                                                                        
         kodepat=awname+'0'+nowo                                                                                                                                                                                                                          
      case blank=0                                                                                                                                                                                                                                        
         kodepat=awname+nowo                                                                                                                                                                                                                              
      endcase


** DEBUG - DO I NEED THIS ??
**      &PATI=KODEPAT

      *      SAVE ALL LIKE PT* TO N:PATI                                                                                                                                                                                                                  
      LOCA FOR PAT_INIT = AWNAME                                                                                                                                                                                                                          
      IF REC_LOCK()                                                                                                                                                                                                                                       
         REPL PAT_NUMB WITH PNUM                                                                                                                                                                                                                          
      ENDIF                                                                                                                                                                                                                                               
      UNLOCK                                                                                                                                                                                                                                              
      if AEAM .OR. PER .OR. DOC .OR. FAM                                                                                                                                                                                                                  
         codcre='1'                                                                                                                                                                                                                                       
      else                                                                                                                                                                                                                                                
         codcre='0'                                                                                                                                                                                                                                       
      endif                                                                                                                                                                                                                                               
                                                                                                                                                                                                                                                          
**    Amended by dickson (26/12/98)                                                                                                                                                                                                                       
**      allows the user to Select/Enter  the Patient code ..                                                                                                                                                                                              
**                                                                                                                                                                                                                                                        
**                                                                                                                                                                                                                                                        
      KODE_OK = .F.                                                                                                                                                                                                                                       
      OLD_KODEPAT = KODEPAT                                                                                                                                                                                                                               
                                                                                                                                                                                                                                                          
      SELE 7                                                                                                                                                                                                                                              
      USE &DR&F1                                                                                                                                                                                                                                          
      SET INDEX TO &DR&F1                                                                                                                                                                                                                                 
                                                                                                                                                                                                                                                          
      DO WHILE !KODE_OK                                                                                                                                                                                                                                   
                                                                                                                                                                                                                                                          
         * THIS IS TO CATER FOR THE LOGIC ERROR WHEN KODEPAT IS EMPTY                                                                                                                                                                                     
         IF LEN(ALLTRIM(KODEPAT)) = 0                                                                                                                                                                                                                     
            KODEPAT = OLD_KODEPAT                                                                                                                                                                                                                         
         ENDIF                                                                                                                                                                                                                                            
         DO BOXEN WITH 14,3,'Enter/Select Patient Code :','KODEPAT','BG+','B','W+','N',6                                                                                                                                                                  
         KODEPAT = ALLTRIM(KODEPAT)                                                                                                                                                                                                                       
         IF LEN(KODEPAT) > 0                                                                                                                                                                                                                              
                                                                                                                                                                                                                                                          
**	 FIND PATIENT CODE ALREADY EXIST OR NOT                                                                                                                                                                                                                
                                                                                                                                                                                                                                                          
	 SEEK KODEPAT                                                                                                                                                                                                                                            
                                                                                                                                                                                                                                                          
            IF EOF()                                                                                                                                                                                                                                      
               KODE_OK = .T.                                                                                                                                                                                                                              
            ELSE                                                                                                                                                                                                                                          
               @ 13,03 SAY 'Patient Code '+KODEPAT+'  ALREADY EXIST, PLEASE SELECT ANOTHER ONE!!'                                                                                                                                                         
            ENDIF                                                                                                                                                                                                                                         
         ENDIF                                                                                                                                                                                                                                            
      ENDDO                                                                                                                                                                                                                                               
**     -- end amended by Dickson                                                                                                                                                                                                                          
                                                                                                                                                                                                                                                          
      DO BOXT WITH 12,3,"PATIENT CODE : "+KODEPAT+' '+COCOD+' '+CODCRE+' '+CODDAT+' '+CODTYP,'bg+','gr',.f.,.T.                                                                                                                                           
      DO BOXNOE WITH 15,3,'Entered by :','ENTNAM','BG+','B','W+','N',16,.F.,.t.                                                                                                                                                                             
                                                                                                                                                                                                                                                          
                                                                                                                                                                                                                                                          
      CONT='Y'                                                                                                                                                                                                                                            
      sele 1                                                                                                                                                                                                                                              
      do presav                                                                                                                                                                                                                                           
      sele 1                                                                                                                                                                                                                                              
      IF P10=1                                                                                                                                                                                                                                            
         DO CMSSAV                                                                                                                                                                                                                                        
         sele 1                                                                                                                                                                                                                                           
      ENDIF                                                                                                                                                                                                                                               
                                                                                                                                                                                                                                                          
                                                                                                                                                                                                                                                          
   ENDDO                                                                                                                                                                                                                                                  
   IF PER .OR. DOC .OR. FAM                                                                                                                                                                                                                               
      DO EMPREG                                                                                                                                                                                                                                           
   ENDIF                                                                                                                                                                                                                                                  
   IF PATRV                                                                                                                                                                                                                                               
      ANO=.F.                                                                                                                                                                                                                                             
   ELSE                                                                                                                                                                                                                                                   
      DO BOX2 WITH 21,3,"DO YOU WANT TO REGISTER ANOTHER PATIENT ? :","YES","NO",'gr+','r','gR+','B',ANOT,.f.,.T.                                                                                                                                         
      IF ANOT=1                                                                                                                                                                                                                                           
         ANO=.t.                                                                                                                                                                                                                                          
      ENDIF                                                                                                                                                                                                                                               
      IF LASTKEY()=27                                                                                                                                                                                                                                     
         RETURN                                                                                                                                                                                                                                           
      ENDIF                                                                                                                                                                                                                                               
   ENDIF                                                                                                                                                                                                                                                  
ENDDO                                                                                                                                                                                                                                                     
RETURN                                                                                                                                                                                                                                                    
                                                                                                                                                                                                                                                          
                                                                                                                                                                                                                                                          
*Formatted by: Herman T Ver. 7.1  on June 19, 1996.                                                                                                                                                                                                       
